unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs, WideStrings,
  StdCtrls, FMTBcd, DBClient, SimpleDS, SqlExpr, DB, DBTables,
  JvExStdCtrls, JvListBox, JvDriveCtrls, Generics.collections;

type
  TFieldDic = TDictionary<string, TField>;
  TMapDic = TDictionary<string, integer>;

  TForm1 = class(TForm)
    tblBDEMain: TTable;
    tblBDEAux: TTable;
    tblFirebird: TSimpleDataSet;
    dbFirebird: TSQLConnection;
    StaticText1: TStaticText;
    dirPortal: TJvDirectoryListBox;
    btnConvert: TButton;
    lblConverting: TStaticText;
    Memo1: TMemo;
    tblFirebirdAux: TSimpleDataSet;
    qryClear: TSQLQuery;
    procedure FormShow(Sender: TObject);
    procedure dirPortalChange(Sender: TObject);
    procedure btnConvertClick(Sender: TObject);
    procedure tblFirebirdBeforePost(DataSet: TDataSet);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
     FCurrTable: string;
     FFieldDic: TFieldDic;
     FMapDic: TMapDic;
     FRoomDic: TMapDic;
     FKs: TStringList;
     procedure ConvertTable(const table: string);
     procedure CopyTables;
     procedure CopyRooms;
     procedure CopyExits;
     procedure CopyMudList;
     function GetNewInteger: integer;
     function GetField(const fieldname: string): TField;
     procedure SetCurrTable(const Value: string);
     procedure AddFKProblem(const name: string);
    procedure CleanupFKs;

     property currTable: string read FCurrTable write SetCurrTable;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation
uses
   ioUtils, types, registry,
   warningDialog,
   DBXDynalink; //to make the Firebird driver load properly
{$R *.dfm}

type EMissingObject = class(Exception);

procedure TForm1.AddFKProblem(const name: string);
begin
   if FKs = nil then
      FKs := TStringList.Create;
   FKs.Add(name);
end;

procedure TForm1.btnConvertClick(Sender: TObject);
const
   WARN_QUESTION = 'This database contains active profiles.  Continuing will delete ' +
                   'all data currently in the database.  Continue?';
var
   dbFiles: TStringDynArray;
   filename, table: string;
begin
   qryClear.Active := false;
   qryClear.SQL.Text := 'select count(*) as PROFCOUNT from PROFILES';
   qryClear.Active := true;
   if qryClear.FieldByName('PROFCOUNT').AsInteger > 0 then
   begin
     if TWarnDialog.ShowQuestion(WARN_QUESTION) <> mrOK then
       Exit;
   end;

   self.Cursor := crHourGlass;
   btnConvert.enabled := false;
   try
      dbFiles := ioUtils.TDirectory.GetFiles(dirPortal.directory, '*.db');
      for filename in dbFiles do
      begin
         table := ExtractFileName(filename);
         if memo1.Lines.IndexOf(table) = -1 then
            memo1.Lines.Add(table);
      end;
      for table in memo1.Lines do
         convertTable(table);
      CleanupFKs;
      lblConverting.Caption := 'Finished!';
      application.MessageBox('Finished', 'Done converting.');
   finally
      self.Cursor := crDefault;
   end;
end;

procedure TForm1.CleanupFKs;
var
   lFKs: TStringList;
   table: string;
   lfkCount: integer;
begin
   if FKs = nil then
      Exit;
   lFKs := FKs;
   try
      FKs := nil;
      lfkCount := lFKs.Count;
      for table in lFKs do
         convertTable(table);
      if assigned(FKs) then
      begin
         if FKs.Count = lfkCount then
            raise Exception.CreateFmt('Unresolvable FK conflicts in the following table(s). Please report this as an error: ', [FKs.CommaText])
         else CleanupFKs;
      end;
   finally
      lFKs.Free;
   end;
end;

procedure TForm1.ConvertTable(const table: string);
const
   SQL_SELECT = 'SELECT * FROM :table';
   CLEAR_QUERY = 'delete from %s';
var
   tableName: string;
begin
   currTable := table;
   lblConverting.Caption := format('Converting table %s...', [table]);
   Application.ProcessMessages;

   tblBDEMain.Close;
   tblBDEMain.TableName := table;
   tblBDEMain.Open;
   tableName := upperCase(copy(table, 1, length(table) - 3));

   if (tablename = 'MUDLISTDESC') or (tableName = 'ROOMMEMOS') then
      Exit;
   if tablename = 'RETAIN' then
      tablename := 'RETAIN_TBL';

   qryClear.SQL.Text := format(CLEAR_QUERY, [tableName]);
   qryClear.ExecSQL;
   qryClear.Close;

   tblFirebird.Close;
   tblFirebird.DataSet.CommandText := stringReplace(SQL_SELECT, ':table', tableName, []);;
   tblFirebird.Open;

   if tablename = 'ROOMS' then
      CopyRooms
   else if tablename = 'EXITS' then
      CopyExits
   else if tablename = 'MUDLIST' then
      CopyMudlist
   else CopyTables;
   try
      tblFirebird.ApplyUpdates(1);
   except
      on E: Exception do
         if pos('FOREIGN', E.Message) > 0 then
            AddFKProblem(table);
         else raise;
   end;
end;

procedure TForm1.CopyExits;

var
   field: TField;
   map, x, y: integer;

   function DetermineMapID: integer;
   begin
      if not FMapDic.TryGetValue(field.AsString, result) then
         raise EMissingObject.Create('');
   end;

   function DetermineRoomID: integer;
   const
      ROOMID_STR = '(MAP_ID = %d) and (X = %d) and (Y = %d)';
   var
      key: string;
   begin
      key := format(ROOMID_STR, [map, x, y]);
      if not FRoomDic.TryGetValue(key, result) then
      begin
         tblFirebirdAux.Filter := key;
         result := tblFirebirdAux.FieldByName('ROOM_ID').AsInteger;
         if result = 0 then
            raise EMissingObject.Create('');
         FRoomDic.Add(key, result);
      end;
   end;

const
   AUX_SQL = 'SELECT * FROM ROOMS';
var
   fieldname: string;
begin
   tblFirebirdAux.Active := false;
   tblFirebirdAux.DataSet.CommandText := AUX_SQL;
   tblFirebirdAux.Active := true;
   tblFirebirdAux.Filtered := true;

   tblBDEMain.First;
   while not tblBDEMain.Eof do
   begin
      tblFirebird.Append;
      try
         for field in tblBDEMain.Fields do
         begin
            fieldname := field.FieldName;
            if FieldName = 'Map' then
            begin
               map := DetermineMapID;
               getField('MAP1').AsInteger := map;
            end
            else if FieldName = 'Map2' then
            begin
               map := DetermineMapID;
               getField('MAP2').AsInteger := map;
            end
            else if (FieldName = 'X') or (FieldName = 'X2') then
               X := field.AsInteger
            else if FieldName = 'Y' then
            begin
               Y := field.AsInteger;
               getField('ROOM1').AsInteger := DetermineRoomID;
            end
            else if FieldName = 'Y2' then
            begin
               Y := field.AsInteger;
               getField('ROOM2').AsInteger := DetermineRoomID;
            end
            else getField(field.FieldName).Value := field.Value;
         end;
         tblFirebird.Post;
      except
         on EMissingObject do
            tblFirebird.Cancel;
      end;
      tblBDEMain.Next;
   end;
   tblFirebirdAux.Active := false;
   tblFirebirdAux.Filter := '';
end;

procedure TForm1.CopyMudList;
const
   DESC_FILTER = 'NORDER = %d';
var
   field: TField;
begin
   tblBDEAux.Active := false;
   tblBDEAux.TableName := 'MudlistDesc.db';
   tblBDEAux.Active := true;
   tblBDEAux.Filtered := true;

   tblBDEMain.First;
   while not tblBDEMain.Eof do
   begin
      tblFirebird.Append;
      for field in tblBDEMain.Fields do
         getField(field.FieldName).Value := field.Value;
      tblBDEAux.Filter := format(DESC_FILTER, [getField('NORDER').AsInteger]);
      getField('DESCRIPTION').Value := tblBDEAux.FieldByName('DESCRIPTION').Value;
      tblFirebird.Post;
      tblBDEMain.Next;
   end;
   tblBDEAux.Active := false;
   tblBDEAux.Filter := '';
end;

procedure TForm1.CopyRooms;

var
   field: TField;
   mapname: string;

   function DetermineMapID: integer;
   const
      MAPID_STR = 'MAP = %s';
   begin
      mapname := field.AsString;
      if not FMapDic.TryGetValue(mapname, result) then
      begin
         tblFirebirdAux.Filter := format(MAPID_STR, [quotedStr(mapname)]);
         result := tblFirebirdAux.FieldByName('MAP_ID').AsInteger;
         if result = 0 then
            raise EMissingObject.Create('');
         FMapDic.Add(mapname, result);
      end;
   end;

const
   AUX_SQL = 'SELECT * FROM MAPS';
   MEMO_FILTER = '(MAP = %s) and (X = %d) and (Y = %d)';
begin
   tblFirebirdAux.Active := false;
   tblFirebirdAux.DataSet.CommandText := AUX_SQL;
   tblFirebirdAux.Active := true;
   tblFirebirdAux.Filtered := true;

   tblBDEAux.Active := false;
   tblBDEAux.TableName := 'Roommemos.db';
   tblBDEAux.Active := true;
   tblBDEAux.Filtered := true;

   tblBDEMain.First;
   while not tblBDEMain.Eof do
   begin
      tblFirebird.Append;
      try
         for field in tblBDEMain.Fields do
            if field.FieldName <> 'Map' then
               getField(field.FieldName).Value := field.Value
            else getField('MAP_ID').AsInteger := DetermineMapID;
         tblBDEAux.Filter := format(MEMO_FILTER, [quotedStr(mapname), GetField('X').AsInteger, GetField('Y').AsInteger]);
         getField('MEMO').Value := tblBDEAux.FieldByName('MEMO').Value;
         tblFirebird.Post;
      except
         on EMissingObject do
            tblFirebird.Cancel;
      end;
      tblBDEMain.Next;
   end;
   tblFirebirdAux.Active := false;
   tblFirebirdAux.Filter := '';
   tblBDEAux.Active := false;
   tblBDEAux.Filter := '';
end;

procedure TForm1.CopyTables;
var
   field: TField;
begin
   tblBDEMain.First;
   while not tblBDEMain.Eof do
   begin
      tblFirebird.Append;
      for field in tblBDEMain.Fields do
         getField(field.FieldName).Value := field.Value;
      tblFirebird.Post;
      tblBDEMain.Next;
   end;
end;

function GetRegistryValue(root: cardinal; KeyName, valueName: string): string;
var
  Registry: TRegistry;
begin

   Registry := TRegistry.Create(KEY_READ);
   try
     Registry.RootKey := root;
     if not Registry.OpenKey(KeyName, False) then
       Exit('');
     result := Registry.ReadString(valueName);
   finally
     Registry.Free;
   end;
end;

procedure TForm1.dirPortalChange(Sender: TObject);
begin
   btnConvert.Enabled := fileExists(IncludeTrailingPathDelimiter(dirPortal.directory) + 'Actions.db');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
   FFieldDic := TFieldDic.Create;
   FMapDic := TMapDic.Create;
   FRoomDic := TMapDic.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
   FKs.free;
   FFieldDic.Free;
   FMapDic.Free;
   FRoomDic.Free;
end;

procedure TForm1.FormShow(Sender: TObject);
const
   PORTAL_KEY = 'SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\Portal.exe';
var
   test: string;
   folder: string;
begin
   folder := '';
   test := IncludeTrailingPathDelimiter(GetRegistryValue(HKEY_LOCAL_MACHINE, PORTAL_KEY, 'Path'));
   if test = '\' then
      test := IncludeTrailingPathDelimiter(GetRegistryValue(HKEY_CURRENT_USER, PORTAL_KEY, 'Path'));
   if test <> '\' then
      if fileExists(test + 'Portal.exe') then
         folder := test + 'Data\';
   if folder = '' then
      dirPortal.directory := 'C:\'
   else dirPortal.directory := folder;
   tblBDEMain.DatabaseName := folder;
   tblBDEAux.DatabaseName := folder;
   dbFirebird.DriverName := 'FirebirdConnection';
   dbFirebird.Params.Add('User_Name=SYSDBA');
   dbFirebird.Params.Add('Password=masterkey');
   dbFirebird.Params.Add(format('Database=%s\data\portal.fdb',
                                [ExcludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)))]));
   dbFirebird.Open;
end;

function TForm1.GetField(const fieldname: string): TField;
begin
   if not FFieldDic.TryGetValue(fieldname, result) then
   begin
      result := tblFirebird.FindField(fieldname);
      if not assigned(result) then
         result := tblFirebird.FieldByName(format('F%s', [fieldname]));
      FFieldDic.Add(fieldname, result);
   end;
end;

var
   globalCounter: integer = 0;

function TForm1.GetNewInteger: integer;
begin
   inc(globalCounter);
   result := globalCounter;
end;

procedure TForm1.SetCurrTable(const Value: string);
begin
   FCurrTable := Value;
   FFieldDic.Clear;
end;

procedure TForm1.tblFirebirdBeforePost(DataSet: TDataSet);
var
   field: TField;
begin
   for field in dataset.fields do
      if (field.Required) and (field.IsNull) then
         field.AsInteger := GetNewInteger;
end;

end.
